perm filename TREST.F4[1,MUS] blob sn#075920 filedate 1973-12-04 generic text, type T, neo UTF8
00100		SUBROUTINE TAIL(RJX,RA,RMINI)
00200		COMMON /STF/RSTFAC(8),RSTJC
00300		COMMON /PLTR/IPLT,RHT,DIS
00400		DIMENSION JARY(1),ITAIL(23)
00500		IF(JARY(1).EQ.0)CALL RDDATA('TAIL',JARY,ITAIL)
00600	CC	R=ABS(RA)
00700		Q=-1.
00800		IF(RA)Q=1.
00900		CALL CENTER(RJY)
01000		CALL JDRAW(ITAIL(1),RJX,RJY,RMINI,1.,Q)
01100	1	IF(IPLT.GE.0)RETURN
01200		IF(RMINI.NE.RSTJC)Q=Q*.6
01300		CALL FILLER(ITAIL(ITAIL(1)+2),RJX,RJY,ABS(Q),Q)
01400	CC	IF(IPLT)CALL FILLER(ITAIL(ITAIL(1)+2),RJX,RJY,1.,RQ)
01500	C RA=-,STEM UP;  RA=+, STEM DOWN.
01600		END
01700	
01800		SUBROUTINE REST
01900		COMMON /STF/RSTFAC(8),RSTJC
02000		COMMON /PLTR/IPLT,RHT,DIS
02100		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
02200		EQUIVALENCE(JE,JQ(3))
02300		DIMENSION LRST(4),IRST(74)
02400	
02500		IF(LRST(1).EQ.0)CALL RDDATA('REST',LRST,IRST)
02600		L=JE
02700		IF(L.GT.1)L=1
02800		K=LRST(L+3)
02900	C  L>3 WHEN SEVERAL TAILS ON REST
03000		CALL CENTER(CENTR)
03100		CALL JDRAW(IRST(K),RJB,CENTR,RSTJC,1.,1.)
03200		IF(JE.OR.IPLT.GE.0)RETURN
03300		CALL FILLER(IRST(IRST(K)+K+1),RJB,CENTR,1.,1.)
03400	C  WHY GO THROUGH NOTWRT??
03500		END
03600	
03700		SUBROUTINE RDDATA(NM,JARY,IARY)
03800	C  READS DATA 
03900		DIMENSION JARY(1),IARY(1)
04000		REWIND 23
04100		CALL IFILE(23,NM)
04200		READ(23,5)K,(JARY(K),K=1,10)
04300		N=1
04400	1	READ(23,5,END=2)K,L,(IARY(K),K=N,N+L-1)
04500		N=N+L
04600		GO TO 1
04700	2	RETURN
04800	5	FORMAT(12I)
04900		END
05000	
05100	C  FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
05200		SUBROUTINE BREP(RJB,RSTJC)
05300		DIMENSION JREP(1),IREP(36)
05400		IF(JREP(1).EQ.0)CALL RDDATA('BREP',JREP,IREP)
05500		CALL CENTER(R)
05600		CALL JDRAW(IREP,RJB,R,RSTJC,1.,1.)
05700		END
05800	
05900		SUBROUTINE FERMTA(RINV)
06000		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
06100		COMMON /PLTR/IPLT,RHT,DIS
06200		COMMON /STF/RSTFAC(8),RSTJC
06300		DIMENSION JFERM(1),IFERM(39)
06400		IF(JFERM(1).EQ.0)CALL RDDATA('FERM',JFERM,IFERM)
06500	CC	R=INV
06600		CALL JDRAW(IFERM,RJB,CENTR,RSTJC,1.,RINV)
06700		IF(IPLT)CALL FILLER(IFERM(IFERM(1)+2),RJB,CENTR,1.,RINV)
06800		END
06900	
07000		SUBROUTINE EXCH(X,Y)
07100		Z=X
07200		X=Y
07300		Y=Z
07400		END
07500		SUBROUTINE SORT2(RPOS,M)
07600		DIMENSION RPOS(2,200)
07700		L=2
07800	3	J=-1
07900		RX=RPOS(1,L-1)
08000		DO 2 K=L,M
08100		IF(RPOS(1,K).GE.RX)GO TO 2
08200		RX=RPOS(1,K)
08300	C   WHY WERE ALL THE RX'S  JX ????? 9/6/73
08400		J=K
08500	2	CONTINUE
08600		IF(J)GO TO 4
08700		K=L-1
08800		CALL EXCH(RPOS(1,K),RPOS(1,J))
08900		CALL EXCH(RPOS(2,K),RPOS(2,J))
09000	4	L=L+1
09100		IF(L.LE.M)GO TO 3
09200		END
09300